home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / f2c / may_5_92.lha / f2c.VMay_5_1992 / libI77 / rsne.c < prev    next >
C/C++ Source or Header  |  1992-05-07  |  9KB  |  462 lines
  1. #include "f2c.h"
  2. #include "fio.h"
  3. #include "lio.h"
  4.  
  5. #define MAX_NL_CACHE 3    /* maximum number of namelist hash tables to cache */
  6. #define MAXDIM 20    /* maximum number of subscripts */
  7.  
  8.  extern char *malloc(), *memset();
  9.  
  10.  struct dimen {
  11.     ftnlen extent;
  12.     ftnlen curval;
  13.     ftnlen delta;
  14.     ftnlen stride;
  15.     };
  16.  typedef struct dimen dimen;
  17.  
  18.  struct hashentry {
  19.     struct hashentry *next;
  20.     char *name;
  21.     Vardesc *vd;
  22.     };
  23.  typedef struct hashentry hashentry;
  24.  
  25.  struct hashtab {
  26.     struct hashtab *next;
  27.     Namelist *nl;
  28.     int htsize;
  29.     hashentry *tab[1];
  30.     };
  31.  typedef struct hashtab hashtab;
  32.  
  33.  static hashtab *nl_cache;
  34.  static n_nlcache;
  35.  static hashentry **zot;
  36.  extern ftnlen typesize[];
  37.  
  38.  extern flag lquit;
  39.  extern int lcount, nml_read;
  40.  extern int (*l_getc)(), (*l_ungetc)(), t_getc();
  41.  
  42. #ifdef ungetc
  43.  static int
  44. un_getc(x,cf) int x; FILE *cf;
  45. { return ungetc(x,cf); }
  46. #else
  47. #define un_getc ungetc
  48.  extern int ungetc();
  49. #endif
  50.  
  51.  static Vardesc *
  52. hash(ht, s)
  53.  hashtab *ht;
  54.  register char *s;
  55. {
  56.     register int c, x;
  57.     register hashentry *h;
  58.     char *s0 = s;
  59.  
  60.     for(x = 0; c = *s++; x = x & 0x4000 ? ((x << 1) & 0x7fff) + 1 : x << 1)
  61.         x += c;
  62.     for(h = *(zot = ht->tab + x % ht->htsize); h; h = h->next)
  63.         if (!strcmp(s0, h->name))
  64.             return h->vd;
  65.     return 0;
  66.     }
  67.  
  68.  hashtab *
  69. mk_hashtab(nl)
  70.  Namelist *nl;
  71. {
  72.     int nht, nv;
  73.     hashtab *ht;
  74.     Vardesc *v, **vd, **vde;
  75.     hashentry *he;
  76.  
  77.     hashtab **x, **x0, *y;
  78.     for(x = &nl_cache; y = *x; x0 = x, x = &y->next)
  79.         if (nl == y->nl)
  80.             return y;
  81.     if (n_nlcache >= MAX_NL_CACHE) {
  82.         /* discard least recently used namelist hash table */
  83.         y = *x0;
  84.         free((char *)y->next);
  85.         y->next = 0;
  86.         }
  87.     else
  88.         n_nlcache++;
  89.     nv = nl->nvars;
  90.     if (nv >= 0x4000)
  91.         nht = 0x7fff;
  92.     else {
  93.         for(nht = 1; nht < nv; nht <<= 1);
  94.         nht += nht - 1;
  95.         }
  96.     ht = (hashtab *)malloc(sizeof(hashtab) + (nht-1)*sizeof(hashentry *)
  97.                 + nv*sizeof(hashentry));
  98.     if (!ht)
  99.         return 0;
  100.     he = (hashentry *)&ht->tab[nht];
  101.     ht->nl = nl;
  102.     ht->htsize = nht;
  103.     ht->next = nl_cache;
  104.     nl_cache = ht;
  105.     memset((char *)ht->tab, 0, nht*sizeof(hashentry *));
  106.     vd = nl->vars;
  107.     vde = vd + nv;
  108.     while(vd < vde) {
  109.         v = *vd++;
  110.         if (!hash(ht, v->name)) {
  111.             he->next = *zot;
  112.             *zot = he;
  113.             he->name = v->name;
  114.             he->vd = v;
  115.             he++;
  116.             }
  117.         }
  118.     return ht;
  119.     }
  120.  
  121. static char Alpha[256], Alphanum[256];
  122.  
  123.  static void
  124. nl_init() {
  125.     register char *s;
  126.     register int c;
  127.  
  128.     if(!init)
  129.         f_init();
  130.     for(s = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"; c = *s++; )
  131.         Alpha[c]
  132.         = Alphanum[c]
  133.         = Alpha[c + 'a' - 'A']
  134.         = Alphanum[c + 'a' - 'A']
  135.         = c;
  136.     for(s = "0123456789_"; c = *s++; )
  137.         Alphanum[c] = c;
  138.     }
  139.  
  140. #define GETC(x) (x=(*l_getc)())
  141. #define Ungetc(x,y) (*l_ungetc)(x,y)
  142.  
  143.  static int
  144. getname(s, slen)
  145.  register char *s;
  146.  int slen;
  147. {
  148.     register char *se = s + slen - 1;
  149.     register int ch;
  150.  
  151.     GETC(ch);
  152.     if (!(*s++ = Alpha[ch & 0xff])) {
  153.         if (ch != EOF)
  154.             ch = 115;
  155.         err(elist->cierr, ch, "namelist read");
  156.         }
  157.     while(*s = Alphanum[GETC(ch) & 0xff])
  158.         if (s < se)
  159.             s++;
  160.     if (ch == EOF)
  161.         err(elist->cierr, EOF, "namelist read");
  162.     if (ch > ' ')
  163.         Ungetc(ch,cf);
  164.     return *s = 0;
  165.     }
  166.  
  167.  static int
  168. getnum(chp, val)
  169.  int *chp;
  170.  ftnlen *val;
  171. {
  172.     register int ch, sign;
  173.     register ftnlen x;
  174.  
  175.     while(GETC(ch) <= ' ' && ch >= 0);
  176.     if (ch == '-') {
  177.         sign = 1;
  178.         GETC(ch);
  179.         }
  180.     else {
  181.         sign = 0;
  182.         if (ch == '+')
  183.             GETC(ch);
  184.         }
  185.     x = ch - '0';
  186.     if (x < 0 || x > 9)
  187.         return 115;
  188.     while(GETC(ch) >= '0' && ch <= '9')
  189.         x = 10*x + ch - '0';
  190.     while(ch <= ' ' && ch >= 0)
  191.         GETC(ch);
  192.     if (ch == EOF)
  193.         return EOF;
  194.     *val = sign ? -x : x;
  195.     *chp = ch;
  196.     return 0;
  197.     }
  198.  
  199.  static int
  200. getdimen(chp, d, delta, extent, x1)
  201.  int *chp;
  202.  dimen *d;
  203.  ftnlen delta, extent, *x1;
  204. {
  205.     register int k;
  206.     ftnlen x2, x3;
  207.  
  208.     if (k = getnum(chp, x1))
  209.         return k;
  210.     x3 = 1;
  211.     if (*chp == ':') {
  212.         if (k = getnum(chp, &x2))
  213.             return k;
  214.         x2 -= *x1;
  215.         if (*chp == ':') {
  216.             if (k = getnum(chp, &x3))
  217.                 return k;
  218.             if (!x3)
  219.                 return 123;
  220.             x2 /= x3;
  221.             }
  222.         if (x2 < 0 || x2 >= extent)
  223.             return 123;
  224.         d->extent = x2 + 1;
  225.         }
  226.     else
  227.         d->extent = 1;
  228.     d->curval = 0;
  229.     d->delta = delta;
  230.     d->stride = x3;
  231.     return 0;
  232.     }
  233.  
  234.  static char where0[] = "namelist read start ";
  235.  
  236. x_rsne(a)
  237.  cilist *a;
  238. {
  239.     int ch, got1, k, n, nd;
  240.     Namelist *nl;
  241.     static char where[] = "namelist read";
  242.     char buf[64];
  243.     hashtab *ht;
  244.     Vardesc *v;
  245.     dimen *dn, *dn0, *dn1;
  246.     ftnlen *dims, *dims1;
  247.     ftnlen b, b0, b1, ex, no, no1, nomax, size, span;
  248.     ftnint type;
  249.     char *vaddr;
  250.     long iva, ivae;
  251.     dimen dimens[MAXDIM], substr;
  252.  
  253.     if (!Alpha['a'])
  254.         nl_init();
  255.     reading=1;
  256.     formatted=1;
  257.     got1 = 0;
  258.     for(;;) switch(GETC(ch)) {
  259.         case EOF:
  260.             err(a->ciend,(EOF),where0);
  261.         case '&':
  262.         case '$':
  263.             goto have_amp;
  264.         default:
  265.             if (ch <= ' ' && ch >= 0)
  266.                 continue;
  267.             err(a->cierr, 115, where0);
  268.         }
  269.  have_amp:
  270.     if (ch = getname(buf,sizeof(buf)))
  271.         return ch;
  272.     nl = (Namelist *)a->cifmt;
  273.     if (strcmp(buf, nl->name))
  274.         err(a->cierr, 118, where0);
  275.     ht = mk_hashtab(nl);
  276.     if (!ht)
  277.         err(elist->cierr, 113, where0);
  278.     for(;;) {
  279.         for(;;) switch(GETC(ch)) {
  280.             case EOF:
  281.                 if (got1)
  282.                     return 0;
  283.                 err(a->ciend,(EOF),where0);
  284.             case '/':
  285.             case '$':
  286.                 return 0;
  287.             default:
  288.                 if (ch <= ' ' && ch >= 0 || ch == ',')
  289.                     continue;
  290.                 Ungetc(ch,cf);
  291.                 if (ch = getname(buf,sizeof(buf)))
  292.                     return ch;
  293.                 goto havename;
  294.             }
  295.  havename:
  296.         v = hash(ht,buf);
  297.         if (!v)
  298.             err(a->cierr, 119, where);
  299.         while(GETC(ch) <= ' ' && ch >= 0);
  300.         vaddr = v->addr;
  301.         type = v->type;
  302.         if (type < 0) {
  303.             size = -type;
  304.             type = TYCHAR;
  305.             }
  306.         else
  307.             size = typesize[type];
  308.         ivae = size;
  309.         iva = 0;
  310.         if (ch == '(' /*)*/ ) {
  311.             dn = dimens;
  312.             if (!(dims = v->dims)) {
  313.                 if (type != TYCHAR)
  314.                     err(a->cierr, 122, where);
  315.                 if (k = getdimen(&ch, dn, (ftnlen)size,
  316.                         (ftnlen)size, &b))
  317.                     err(a->cierr, k, where);
  318.                 if (ch != ')')
  319.                     err(a->cierr, 115, where);
  320.                 b1 = dn->extent;
  321.                 if (--b < 0 || b + b1 > size)
  322.                     return 124;
  323.                 iva += b;
  324.                 size = b1;
  325.                 while(GETC(ch) <= ' ' && ch >= 0);
  326.                 goto scalar;
  327.                 }
  328.             nd = dims[0];
  329.             nomax = span = dims[1];
  330.             ivae = iva + size*nomax;
  331.             if (k = getdimen(&ch, dn, size, nomax, &b))
  332.                 err(a->cierr, k, where);
  333.             no = dn->extent;
  334.             b0 = dims[2];
  335.             dims1 = dims += 3;
  336.             ex = 1;
  337.             for(n = 1; n++ < nd; dims++) {
  338.                 if (ch != ',')
  339.                     err(a->cierr, 115, where);
  340.                 dn1 = dn + 1;
  341.                 span /= *dims;
  342.                 if (k = getdimen(&ch, dn1, dn->delta**dims,
  343.                         span, &b1))
  344.                     err(a->cierr, k, where);
  345.                 ex *= *dims;
  346.                 b += b1*ex;
  347.                 no *= dn1->extent;
  348.                 dn = dn1;
  349.                 }
  350.             if (ch != ')')
  351.                 err(a->cierr, 115, where);
  352.             b -= b0;
  353.             if (b < 0 || b >= nomax)
  354.                 err(a->cierr, 125, where);
  355.             iva += size * b;
  356.             dims = dims1;
  357.             while(GETC(ch) <= ' ' && ch >= 0);
  358.             no1 = 1;
  359.             dn0 = dimens;
  360.             if (type == TYCHAR && ch == '(' /*)*/) {
  361.                 if (k = getdimen(&ch, &substr, size, size, &b))
  362.                     err(a->cierr, k, where);
  363.                 if (ch != ')')
  364.                     err(a->cierr, 115, where);
  365.                 b1 = substr.extent;
  366.                 if (--b < 0 || b + b1 > size)
  367.                     return 124;
  368.                 iva += b;
  369.                 b0 = size;
  370.                 size = b1;
  371.                 while(GETC(ch) <= ' ' && ch >= 0);
  372.                 if (b1 < b0)
  373.                     goto delta_adj;
  374.                 }
  375.             for(; dn0 < dn; dn0++) {
  376.                 if (dn0->extent != *dims++ || dn0->stride != 1)
  377.                     break;
  378.                 no1 *= dn0->extent;
  379.                 }
  380.             if (dn0 == dimens && dimens[0].stride == 1) {
  381.                 no1 = dimens[0].extent;
  382.                 dn0++;
  383.                 }
  384.  delta_adj:
  385.             ex = 0;
  386.             for(dn1 = dn0; dn1 <= dn; dn1++)
  387.                 ex += (dn1->extent-1)
  388.                     * (dn1->delta *= dn1->stride);
  389.             for(dn1 = dn; dn1 > dn0; dn1--) {
  390.                 ex -= (dn1->extent - 1) * dn1->delta;
  391.                 dn1->delta -= ex;
  392.                 }
  393.             }
  394.         else if (dims = v->dims) {
  395.             no = no1 = dims[1];
  396.             ivae = iva + no*size;
  397.             }
  398.         else
  399.  scalar:
  400.             no = no1 = 1;
  401.         if (ch != '=')
  402.             err(a->cierr, 115, where);
  403.         got1 = nml_read = 1;
  404.         lcount = 0;
  405.      readloop:
  406.         for(;;) {
  407.             if (iva >= ivae || iva < 0) {
  408.                 lquit = 1;
  409.                 goto mustend;
  410.                 }
  411.             else if (iva + no1*size > ivae)
  412.                 no1 = (ivae - iva)/size;
  413.             lquit = 0;
  414.             l_read(&no1, vaddr + iva, size, type);
  415.             if (lquit == 1)
  416.                 return 0;
  417.  mustend:
  418.             if (GETC(ch) == '/' || ch == '$') {
  419.                 lquit = 1;
  420.                 return 0;
  421.                 }
  422.             else if (lquit) {
  423.                 while(ch <= ' ' && ch >= 0)
  424.                     GETC(ch);
  425.                 Ungetc(ch,cf);
  426.                 if (!Alpha[ch & 0xff] && ch >= 0)
  427.                     err(a->cierr, 125, where);
  428.                 break;
  429.                 }
  430.             Ungetc(ch,cf);
  431.             if ((no -= no1) <= 0)
  432.                 break;
  433.             for(dn1 = dn0; dn1 <= dn; dn1++) {
  434.                 if (++dn1->curval < dn1->extent) {
  435.                     iva += dn1->delta;
  436.                     goto readloop;
  437.                     }
  438.                 dn1->curval = 0;
  439.                 }
  440.             break;
  441.             }
  442.         }
  443.     }
  444.  
  445.  integer
  446. s_rsne(a)
  447.  cilist *a;
  448. {
  449.     int n;
  450.     extern integer e_rsle();
  451.     external=1;
  452.     if(n = c_le(a))
  453.         return n;
  454.     if(curunit->uwrt && nowreading(curunit))
  455.         err(a->cierr,errno,where0);
  456.     l_getc = t_getc;
  457.     l_ungetc = un_getc;
  458.     if (n = x_rsne(a))
  459.         return n;
  460.     return e_rsle();
  461.     }
  462.